home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / modprolg / mod-prol.lha / Prolog / modlib / src / $modules.P < prev    next >
Text File  |  1992-05-30  |  7KB  |  202 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * File : $MODULES.P                                                        *
  4.  * Created : 10/12/1991                                                     *
  5.  *                                                                          *
  6.  ****************************************************************************/
  7.  
  8. /****************************************************************************
  9.  *                                                                          *
  10.  * This file has been changed by to include Modules Extensions              *
  11.  * Changes by : Brian Paxton 1991/92                                        *
  12.  * Last update : June 1992                                                  *
  13.  *                                                                          *
  14.  * Organisation : University of Edinburgh.                                  *
  15.  * For : Departments of Computer Science and Artificial Intelligence        * 
  16.  *       Fourth Year Project.                                               *
  17.  *                                                                          *
  18.  ****************************************************************************/
  19.  
  20. /* This file is loaded when the system is booted.
  21.    This file must define the predicate $setup_modules/0
  22. */
  23.  
  24. /* For more information on how the modules environment is represented in
  25.    the database, see file $consult.P */
  26.  
  27. $modules_export([$setup_modules/0,$dismantle_name/3,
  28.         $check_destination/2,$move_clause/4,$isa_structuretag/1,
  29.         $current_structure/2,$structure/3,$structure/4,
  30.         $check_not_function/1]).
  31.  
  32. % setup_modules/0 is called when the system is first booted.
  33.  
  34. $setup_modules :-
  35.     gennum(_),     % Just to ensure that the number 0 is never generated,
  36.                    % as 0 is used for the root structure tag.
  37.     $writename('Modules Extension Version 1.0, June 1992'), $nl,
  38.     $assert(($module_functor(_,_,_,_,_,_,_,_,_,_) :- fail)),
  39.     $assert(($module_signature(_,_,_,_,_) :- fail)),
  40.     $assert($module_structure(root,0,[],[],[])).
  41.  
  42. % $dismantle_name/3
  43. %
  44. % Dismantles a tagged term into its constituents.
  45.  
  46. $dismantle_name(Internal, Name, Tag) :-
  47.     nonvar(Internal),
  48.     $atom(Internal),
  49.     $name0(Internal, Chars),
  50.     $append(Tag0, [0'_,0'_|Name0], Chars), !,
  51.     $name_2(Name, Name0),
  52.     $name(Tag, Tag0).
  53.  
  54. $dismantle_name(Internal, Name, Tag) :-
  55.     var(Internal),
  56.     $atom(Name),
  57.     $integer(Tag),
  58.     $name0(Name, Name0),
  59.     $name(Tag, Tag0),
  60.     $append(Tag0, [0'_,0'_|Name0], Chars), !,
  61.     $name_2(Internal,Chars).
  62.  
  63. $dismantle_name(Internal, Name, perv) :-
  64.     ( $atom(Internal) ; $atom(Name) ),
  65.     Internal = Name.
  66.  
  67.  
  68. % $check_destination(+Clause, -Tag)
  69. %
  70. % Find the structure to which Clause belongs.
  71. % Used by $assert.P and $retr.P
  72.  
  73. $check_destination((Head :- _), Oldtag) :-
  74.     $check_destination(Head, Oldtag),!.
  75. $check_destination(Head, Oldtag) :-
  76.     $pervasive0(Head) -> Oldtag = perv ;
  77.                          ( $functor0(Head,Name),
  78.                    $dismantle_name(Name,_,Oldtag) ).
  79.  
  80. % $move_clause(+Oldterm, +Oldtag, +Newtag, -Newterm)
  81. %
  82. % The tags of term Oldterm are replaced by Newtag to give Newterm. If any of
  83. % Oldterm's existing tags are not equal to Oldtag, then an error is
  84. % written and the call fails.
  85. % Called $move_clause as it is used by $assert.P, $retr.P and $call.P
  86. % to move clauses to remote structures.
  87.  
  88. $move_clause(Term,Tag,Tag,Term) :- !.
  89. $move_clause(Term,_,_,Term) :-
  90.     ( var(Term) ; number(Term) ; $is_buffer(Term) ),!.
  91. $move_clause([],_,_,[]) :- !.
  92. $move_clause([Head|Tail],Old,New,[Nhead|Ntail]) :- !,
  93.     $move_clause(Head,Old,New,Nhead),
  94.     $move_clause(Tail,Old,New,Ntail).
  95. $move_clause(':'(_,_),_,_,_) :- !,
  96.     $writename('*** Error: Cannot assert/retract/call a clause with non-dereferenced paths'),
  97.     $nl, fail.
  98. $move_clause(Term,Old,New,NTerm) :-
  99.     ( $structure(Term) ; $atom(Term) ),
  100.     $univ(Term,[Name|Args]),
  101.     ( $pervasive0(Term) -> Newname = Name ;
  102.         ( ( $dismantle_name(Name, _, Old),
  103.             $arity(Term, Arity),
  104.             $symtype($mapped_function(_,_,_,_),Type),
  105.             ( ( Type > 0,
  106.               $mapped_function(Textual,Arity,Name,Old) ) ;
  107.                Textual = Name ), !,
  108.             $dismantle_name(Textual,Part,_),
  109.             $dismantle_name(Newname0,Part,New),
  110.             ( ( Type > 0,
  111.               $mapped_function(Newname0,Arity,Newname,_) ) ; 
  112.                Newname = Newname0 ) ) ;
  113.           ( $writename('*** Error: Cannot move clause - contains references to substructures'),
  114.             $nl,fail) ) ), !,
  115.     $move_clause(Args,Old,New,Nargs), !,
  116.     $univ(NTerm,[Newname|Nargs]).
  117.  
  118. % $isa_structuretag(Tag)
  119. %
  120. % Checks to see if argument is a structure tag.
  121.  
  122. $isa_structuretag(X) :-
  123.     nonvar(X),
  124.     ( X == perv ;
  125.         ( $symtype($module_structure(_,_,_,_,_), Type),
  126.         Type > 0,
  127.         ( $module_structure(_,X,_,_,_) ;
  128.           ( $module_structure(_,_,Subs,_,_),
  129.             $memberchk(_ ---> X, Subs) ) ) ) ), !.
  130.  
  131. % current_structure(-Strtag)
  132. %
  133. % The user uses a call current_structure/1 which is
  134. % converted by fun_rel/3 into $current_structure(X,<structure tag>).
  135. % Therefore, definition of this predicate is trivial. */
  136.  
  137. $current_structure(X,X).
  138.  
  139. % $structure(Ref, Structure, CurrentStr)
  140. % $structure(Ref, Structure, Withrespectto, CurrentStr)
  141. %
  142. % Return tag of a given names structure (with respect to the third argument
  143. % structure).
  144.  
  145. $structure(Ref, Structure, Current) :-
  146.     $structure(Ref, Structure, 0, Current).
  147.  
  148. $structure(0, root, 0, Current) :- !.
  149.  
  150. $structure(Tag, Name, WRT, Cur) :-
  151.     $get_structure(WRT,_,Wsubs,_,_),
  152.     $dismantle_name(Name,Name0,Ntag),
  153.     ( ( Ntag == Cur ; Ntag == perv ) -> 
  154.             $memberchk(Name0 ---> Tag, Wsubs) ;
  155.         ( $get_structure(Cur,_,Csubs,_,_),
  156.           $member(Substr ---> Ntag, Csubs),
  157.           $prefix_path(Substr,Search,Name0),
  158.           $memberchk(Search ---> Tag, Wsubs) ) ),!.
  159.  
  160. % $get_structure(Tag, Name, Substrs, Preds, Funs)
  161. %
  162. % Given a structure tag, this routine will the return the name and signature
  163. % of that structure. Will build signatures for non-top-level structures too.
  164. % Structures may not have a unique name, so this routine just returns the 
  165. % first it finds.
  166.  
  167. $get_structure(Tag,Name,S,P,F) :-
  168.         $module_structure(Name,Tag,S,P,F), !.
  169.  
  170. $get_structure(Tag,Fullname,S,P,F) :-
  171.         $module_structure(Name,_,S0,P0,F0),
  172.         $memberchk(Str ---> Tag, S0),
  173.         $prefix_path(Str,Search,X),
  174.         $setof(X ---> Y, X^Y^$member(Search ---> Y,S0), S),
  175.         $setof(X/N ---> Y, X^Y^N^$member(Search/N ---> Y,P0), P),
  176.         $setof(X/N ---> Y, X^Y^N^$member(Search/N ---> Y,F0), F),
  177.     ( Name == root -> Fullname = Str ;
  178.                       Fullname = Name:Str ), !.
  179.  
  180. $prefix_path(First:Path, First:Search, X) :- !,
  181.         $prefix_path(Path, Search, X).
  182. $prefix_path(Path, Path:X, X).
  183.  
  184. % $check_not_function(Clause)
  185. %
  186. % Used by the assert and retract family of predicates to check that their
  187. % argument has not been declared as a function.
  188.  
  189. $check_not_function(Clause) :-
  190.     $symtype($declared_function(_), Type),
  191.     Type > 0, !,
  192.     ( Clause = (Head :- _) -> true ;
  193.                               Clause = Head ),
  194.     ( $declared_function(Head) ->
  195.          ( $functor(Head, Name, Arity),
  196.            $writename('*** Error : Cannot assert '),
  197.            $writename(Name), $writename('/'), $writename(Arity),
  198.            $writename(' - it has been declared as a function'), $nl,
  199.            fail ) ;
  200.          true  ), !.
  201. $check_not_function(_).
  202.